home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Icon 8.1 / mep2 / MemMon 2.0 / Samples / singles.icn < prev    next >
Encoding:
Text File  |  1989-12-02  |  2.7 KB  |  123 lines  |  [TEXT/PICN]
  1. #    SHUFFLE(2)
  2. #
  3. #    Shuffle values
  4. #
  5. #    Ralph E. Griswold
  6. #
  7. #    Last modified 5/15/83
  8. #
  9.  
  10. procedure shuffle(x)
  11.    x := string(x)
  12.    if not(type(x) == ("string" | "list")) then xstop(x)
  13.    every !x :=: ?x
  14.    return x
  15. end
  16.  
  17. procedure xstop(x)
  18.    stop("Run-time error 102 in shuffle_
  19.       \nstring or list expected\noffending value: ",
  20.       image(x))
  21. end
  22.  
  23. global zero, one, letters
  24.  
  25. procedure main(a)
  26.    every 1 to 3 do {
  27.    pair := table(0)
  28.    zero := table()
  29.    one:= table()
  30.    number := a[1] | 20
  31.    &random := a[2]
  32.    write("&random=",&random)
  33.    letters := &lcase || &ucase
  34.    labels := letters[1+:number]
  35.    every c := !labels do
  36.       zero[c] := singles(labels,c)
  37.    every c := !labels do
  38.       one[c] := singles(labels,c)
  39.    every round := 1 to 8 do {
  40.       write("\nround ",round,":\n")
  41.       players := shuffle(labels)
  42.       every 1 to number / 4 do {
  43.          setting := s1 := ?players
  44.          players := remove(players,s1)
  45. #        write("s1=",s1)
  46.          until *setting = 4 do {
  47.             s1 := select(s1,players,setting) | stop("cannot construct")
  48.             setting ||:= s1
  49. #           write("setting=",setting)
  50.             players := remove(players,s1)
  51.             }
  52.          display(setting)
  53.          aa := []
  54.          every push(aa,1(s := string(!setting ++ !setting),*s = 2))
  55.          x := set(aa)
  56.          every pair[!x] +:= 1
  57.          }
  58.       write(repl("-",12))
  59.    }
  60.    analyze(pair,labels)
  61.    }
  62. end
  63.  
  64. procedure singles(s,c)
  65.    S := set([])
  66.    every insert(S,c ~== !s)
  67.    return S
  68. end
  69.  
  70. procedure select(s1,base,setting)
  71.    local s2
  72.    if s2 := member(zero[s1],!base) then {
  73.       every delete(zero[!setting],s2)
  74.       every delete(zero[s2],!setting)
  75.       }
  76.    else if s2 := member(one[s1],!base) then {
  77.       every delete(one[!setting],s2)
  78.       every delete(one[s2],!setting)
  79.       }
  80.    else fail
  81.    return s2
  82. end
  83.  
  84. procedure remove(s1,s2)
  85.    s1[find(s2,s1)] := "" | stop("cannot remove")
  86.    return s1
  87. end
  88.  
  89. procedure display(s)
  90.    every writes(right(find(!s,letters),3))
  91.    write()
  92. end
  93.  
  94. procedure analyze(t,s)
  95.    local hits, notes
  96.    hits := list(10,0)
  97.    notes := list(10,"")
  98.    write("number of different pairings is ",*t)
  99.    every pair := string(!s ++ !s) & *pair = 2  do {
  100.       score := t[pair]
  101.       hits[score + 1] +:= 1
  102.       t[pair] := t[reverse(pair)] := 10
  103.       if (score = 0) | (score > 2) then
  104.          notes[score + 1] ||:= pair
  105.       }
  106.    write("pairings:")
  107.    every i := 1 to 10 do
  108.       write(i - 1,":\t",hits[i])
  109.    write("\nnotes:")
  110.       every i := 0 | (3 to 10) do
  111.          write(i,":\n",xlate(notes[i + 1]))
  112. end
  113.  
  114. procedure xlate(s)
  115.    if *s = 0 then fail
  116.    s1 := ""
  117.    every i := 1 to *s by 2 do
  118.       s1 ||:= right(find(s[i],letters),3) || right(find(s[i + 1],letters),3) ||
  119.          "\n"
  120. .a
  121.    return s1
  122. end
  123.